SuperHack/SuperHack CD.bin/CODING/DELPHI/SWEEPGEN.ZIP/MAINFORM.PAS

Pascal/Delphi Source File | 1996-06-01 | 20.7 KB | 648 lines

unit MainForm;

{
SweepGen - David's Audio Sweep Generator

Revision History

V0.0     1994 Oct 09  First version, combining SloSweep and Sinewave
V0.0-01  1994 Oct 10  Use TDlgWindow as main window
                      Move sweep_running to main data segment
V0.0-02  1994 Oct 12  Get double-buffering working properly
                      Put sweep_running back in object data!
V1.0.0   1995 May 07  Version for Delphi 1.0
V1.1.0   1995 Oct 08  Better quality, 16-bit audio
V2.0.0   1996 Jun 01  Version for 32-bit Delphi
                      Add more output levels
                      Allow for smooth or stepped fast sweep
                      Improve generation to about 15-bit accuracy
                      Release to public domain
}

interface

{$A-}
{$D David's Audio Sweep Generator ⌐ David J Taylor, Edinburgh, 1994-1996}

uses
  SysUtils, Windows, Messages, Classes, Graphics, Controls,
  Forms, Dialogs, StdCtrls, ExtCtrls, MMSystem, mmErrMsg;

const
  sweep_time = 45;                   // seconds for slow sweep
  sample_rate = 44100;               // i.e. best CD quality
  sine_table_samples = 1 shl 15;     // number of samples in sine table
  max_buffer_samples = 32000;        // reasonable size of output buffer (< 64K)
  open_error = 'Error opening waveform audio!';
  mem_error = 'Error allocating memory!';

type
  audio_sample = -32767..32767;       // for 16-bit audio

type
  PSineTable = ^TSineTable;          // sine value store
  TSineTable = array [0..sine_table_samples-1] of audio_sample;

  PBuffer = ^TBuffer;                // output buffer type
  TBuffer = array [0..max_buffer_samples-1] of audio_sample;

  levels = (dB0, dB3, dB6, dB9, dB12, dB15, dB18, dB20);  // output levels
  ranges = (lf, mf, hf, wide);                            // sweep ranges
  modes = (logarithmic, linear);                          // sweep modes
  speeds = (fast_stepped, fast_smooth, slow, no_sweep);   // sweep speeds


type
  TForm1 = class(TForm)
    Panel1: TPanel;
    Panel2: TPanel;
    btnExit: TButton;
    grpFrequencyRange: TRadioGroup;
    btnStart: TButton;
    grpSweepMode: TRadioGroup;
    grpSweepSpeed: TRadioGroup;
    grpOutputLevel: TRadioGroup;
    edtF1: TEdit;
    Label1: TLabel;
    edtF2: TEdit;
    Label2: TLabel;
    lblFnow: TLabel;
    procedure btnExitClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure grpSweepModeClick(Sender: TObject);
    procedure grpOutputLevelClick(Sender: TObject);
    procedure grpSweepSpeedClick(Sender: TObject);
    procedure grpFrequencyRangeClick(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure btnStartClick(Sender: TObject);
    procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
  private
    { Private declarations }
    angle: integer;          // current sine wave angle
    sine_table: PSineTable;  // sine-wave values are pre-stored in this array
    p_wave_hdr1: PWaveHdr;   // wave headers
    p_wave_hdr2: PWaveHdr;
    p_buffer1: PBuffer;      // output buffers
    p_buffer2: PBuffer;
    hWave_hdr1: HGlobal;
    hWave_hdr2: HGlobal;
    hBuffer1: HGlobal;
    hBuffer2: HGlobal;
    buffer_bytes: integer;   // max number of bytes in each output buffer
    f_min, f_max: integer;   // limits of sweep range
    buffers_written, buffers_played: integer;  // for tracking the slow sweep
    all_written: boolean;    // so we know when to stop the sweep
    f, f_ratio, f_step, last_f: extended;
    hWave_out: HWaveOut;     // handle to wave out device
    pcm: TWaveFormatEx;      // wave format descriptor
    sweep_running: boolean;
    shutoff: boolean;
    closing: boolean;
    sine_table_done: boolean;
    closed: boolean;
    level: levels;
    log_lin: modes;
    speed: speeds;
    range: ranges;
    procedure restart_sweep;
    procedure stop_sweep;
    procedure start_sweep;

    // call-backs from waveform out functions
    procedure mm_wom_Open (var Msg: TMessage);  message mm_wom_open;
    procedure mm_wom_Done (var Msg: TMessage);  message mm_wom_done;
    procedure mm_wom_Close (var Msg: TMessage);  message mm_wom_close;

    function fill_single_sweep_bfr (bfr: PBuffer;  num_freqs: integer): integer;
    procedure fill_buffer_with_sinewave (bfr: PBuffer;  index, samples: integer);
    procedure write_next_buffer (header: PWaveHdr);
    procedure do_sine_table;

  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}
{$R version.res}

procedure TForm1.FormCreate(Sender: TObject);
begin
  // set the default positions for the RadioGroup boxes, this forces the
  // dependant variables and the label captions to be set
  grpOutputLevel.ItemIndex := 4;
  grpSweepMode.ItemIndex := 1;
  grpFrequencyRange.ItemIndex := 2;
  grpSweepSpeed.ItemIndex := 2;

  // get the memory required for wave headers
  // this code is probably irrelevant in the Win32 environment
  hWave_hdr1 := GlobalAlloc (gHnd or gMem_Share, SizeOf (TWaveHdr));
  p_wave_hdr1 := pWaveHdr (GlobalLock (hWave_hdr1));
  hWave_hdr2 := GlobalAlloc (gHnd or gMem_Share, SizeOf (TWaveHdr));
  p_wave_hdr2 := pWaveHdr (GlobalLock (hWave_hdr2));

  // estimate of reasonable output buffer size
  buffer_bytes := 2 * round (1.2 * sample_rate);
  if buffer_bytes > 2 * max_buffer_samples
    then buffer_bytes := 2 * max_buffer_samples;

  // get the memory required for output buffers
  hBuffer1 := GlobalAlloc (gHnd or gMem_Share, buffer_bytes);
  p_buffer1 := pBuffer (GlobalLock (hBuffer1));
  hBuffer2 := GlobalAlloc (gHnd or gMem_Share, buffer_bytes);
  p_buffer2 := pBuffer (GlobalLock (hBuffer2));

  hWave_out := 0;
  // get the memory for the sine-wave table and note it hasn't been built, yet
  GetMem (sine_table, SizeOf (TSineTable));
  sine_table_done := false;

  // set other state variables
  shutoff := false;
  closing := false;
  sweep_running := false;
end;


procedure TForm1.FormDestroy(Sender: TObject);
begin
  shutoff := true;
  GlobalUnlock (hWave_hdr1);  GlobalFree (hWave_hdr1);
  GlobalUnlock (hBuffer1);  GlobalFree (hBuffer1);
  GlobalUnlock (hWave_hdr2);  GlobalFree (hWave_hdr2);
  GlobalUnlock (hBuffer2);  GlobalFree (hBuffer2);
  FreeMem (sine_table, SizeOf (TSineTable));
end;


procedure TForm1.btnExitClick(Sender: TObject);
begin
  Close;
end;


procedure TForm1.grpSweepModeClick(Sender: TObject);
// This is typical of the code for all the RadioGroups.  Find
// the current string and decode it.  Set a label caption equal
// to the decoded value, often just the current string
var
  current: string;
begin
  current := grpSweepMode.Items.Strings [grpSweepMode.ItemIndex];
  if current = 'Linear' then log_lin := linear;
  if current = 'Log' then log_lin := logarithmic;
  lblFnow.Caption := LowerCase (current);
  // the sweep parameters have changed, so restart any sweep in progress
  restart_sweep;
end;


procedure TForm1.grpOutputLevelClick(Sender: TObject);
var
  current: string;
begin
  current := grpOutputLevel.Items.Strings [grpOutputLevel.ItemIndex];
  if current = '0dB' then level := dB0;
  if current = '-3dB' then level := dB3;
  if current = '-6dB' then level := dB6;
  if current = '-9dB' then level := dB9;
  if current = '-12dB' then level := dB12;
  if current = '-15dB' then level := dB15;
  if current = '-18dB' then level := dB18;
  if current = '-20dB' then level := dB20;
  lblFnow.Caption := current;
  sine_table_done := false;   // level is different, so throw away present table
  restart_sweep;
end;


procedure TForm1.grpSweepSpeedClick(Sender: TObject);
var
  current: string;
begin
  current := grpSweepSpeed.Items.Strings [grpSweepSpeed.ItemIndex];
  if current = 'Slow' then speed := slow;
  if current = 'Fast (stepped)' then speed := fast_stepped;
  if current = 'Fast (smooth)' then speed := fast_smooth;
  if current = 'No sweep' then speed := no_sweep;
  case speed of
    slow, fast_stepped, fast_smooth: edtF2.Visible := True;
    no_sweep: edtF2.Visible := False;
  end;
  lblFnow.Caption := LowerCase (current);
  restart_sweep;
end;


procedure TForm1.grpFrequencyRangeClick(Sender: TObject);
var
  f1, f2: integer;
  current: string;
begin
  current := grpFrequencyRange.Items.Strings [grpFrequencyRange.ItemIndex];
  if current = 'Wide  (20Hz .. 20KHz)' then range := wide;
  if current = 'HF  (1KHz .. 15KHz)' then range := hf;
  if current = 'Speech  (300Hz .. 3KHz)' then range := mf;
  if current = 'LF  (50Hz .. 1KHz)' then range := lf;
  case range of
      lf: begin
          f1 := 50;  f2 := 1000;
          end;
      mf: begin
          f1 := 300;  f2 := 3000;
          end;
      hf: begin
          f1 := 1000;  f2 := 15000;
          end;
    wide: begin
          f1 := 20;  f2 := 20000;
          end;
    else
          begin
          f1 := 300;  f2 := 3000;
          end;
  end;
  // record the new frequency range in the Edit boxes
  edtF1.Text := IntToStr (f1);
  edtF2.Text := IntToStr (f2);
  case range of
    lf: lblFnow.Caption := 'lf';
    mf: lblFnow.Caption := 'mf';
    hf: lblFnow.Caption := 'hf';
    wide: lblFnow.Caption := 'wide';
  end;
  restart_sweep;
end;


procedure TForm1.restart_sweep;
begin
  if sweep_running then start_sweep;
end;


procedure TForm1.stop_sweep;
begin
  // is a sweep running?  if so, stop it
  if sweep_running
  then
    begin
    shutoff := true;
    waveOutReset (hWave_out);
    sweep_running := false;
    closed := false;
    repeat
      Application.ProcessMessages;
    until closed;
    end
end;


procedure TForm1.start_sweep;
var
  open_status: MMRESULT;
  code: integer;
begin
  if sweep_running then stop_sweep;

  // try to convert the text in the edit boxes to numbers
  Val (edtF1.Text, f_min, code);
  if code <> 0 then f_min := 150;
  Val (edtF2.Text, f_max, code);
  if code <> 0 then f_max := 300;

  angle := 0;
  // fill in the TWaveFormatEx structure with our wave details
  with pcm do
    begin
    wFormatTag := wave_Format_PCM;         // it's PCM data
    nChannels := 1;                        // mono
    nSamplesPerSec := sample_rate;         // set the 44.1KHz rate
    nAvgBytesPerSec := 2 * sample_rate;    // two bytes per sample
    nBlockAlign := 2;                      // for mono 16-bit audio
    wBitsPerSample := 16;                  // 16-bit audio
    cbSize := 0;
    end;

  shutoff := false;
  // try and open the wave device for our format of wave data
  open_status := waveOutOpen (@hWave_out, 0, @pcm, Handle, 0, callback_window);

  if open_status = 0
  then
    begin
    // prepare to receive the WaveOutOpen message to sctually start sending data
    sweep_running := true;
    closed := false;
    if (speed = slow) or (speed = no_sweep) then
      begin
      lblFnow.Caption := IntToStr (f_min) + ' Hz';
      lblFnow.Visible := True;
      end;
    end
  else
    begin
    sweep_running := false;
    hWave_out := 0;
    // inform user of failure
    MessageDlg (open_error + #13#10 + translate_mm_error (open_status),
                mtWarning, [mbOK], 0);
    end;
end;


procedure TForm1.btnStartClick(Sender: TObject);
begin
  {is a sweep running?  if so, stop it}
  if sweep_running
  then stop_sweep
  else start_sweep;
end;


procedure TForm1.mm_wom_open (var Msg: tMessage);
// This code handles the WaveOutOpen message by writing two buffers of data
// to the wave device.  Plus other miscellaneous housekeeping.
var
   chunks: integer;
   buffer_fill: integer;
   samples: integer;             // max valid sample in the buffer
begin
  btnStart.Caption := 'STOP';    // first, tell the user how to stop the sound!

  if not sine_table_done then do_sine_table;  // build sine-wave table if required

  // populate the first wave header
  with p_wave_hdr1^ do
    begin
    lpData := pChar (p_buffer1);   // pointer to the data
    dwBufferLength := 0;           // fill in size later
    dwBytesRecorded := 0;
    dwUser := 0;
    dwFlags := 0;
    dwLoops := 1;                  // just a single loop
    lpNext := nil;
    reserved := 0;
    end;

  // populate the second buffer
  p_wave_hdr2^ := p_wave_hdr1^;              // copy most of the data
  p_wave_hdr2^.lpData := pChar (p_buffer2);  // except the buffer address!

  case speed of
    fast_smooth, fast_stepped:
      begin
      // fill in a single buffer that is repeated
      if speed = fast_smooth
      then samples := fill_single_sweep_bfr (p_buffer1, 1000)  // many frequencies
      else samples := fill_single_sweep_bfr (p_buffer1, 20);   // just 20 frequencies
      with p_wave_hdr1^ do
        begin
        dwBufferLength := 2*samples;              // convert samples to bytes
        dwFlags := whdr_BeginLoop or whdr_EndLoop;
        dwLoops := 65535;
        end;
      // prepare both headers but write just the first
      waveOutPrepareHeader (hWave_out, p_wave_hdr1, SizeOf (TWaveHdr));
      waveOutPrepareHeader (hWave_out, p_wave_hdr2, SizeOf (TWaveHdr));
      waveOutWrite (hWave_out, p_wave_hdr1, SizeOf (TWaveHdr));
      end;
    slow, no_sweep:
      begin
        // compute number of chunks in the sweep, ensure it's at least two
        // aim for about four different frequencies per second
        chunks := trunc ((sweep_time * sample_rate) / (sample_rate div 4) + 0.999);
        if chunks < 2 then chunks := 2;
        buffer_fill := (trunc (sweep_time * 2.0 * sample_rate / chunks)) and $FFFFFFFE;
        f_ratio := exp (ln (f_max/f_min) / (chunks-1));       // per step
        f_step := (f_max + 0.01 - f_min) / (chunks-1);
        f := f_min;
        p_wave_hdr1^.dwBufferLength := buffer_fill;     // actual buffer sizes
        p_wave_hdr2^.dwBufferLength := buffer_fill;
        buffers_played := 0;
        buffers_written := 0;
        // now write the first two buffers into the wave output
        waveOutPrepareHeader (hWave_out, p_wave_hdr1, SizeOf (TWaveHdr));
        write_next_buffer (p_wave_hdr1);
        waveOutPrepareHeader (hWave_out, p_wave_hdr2, SizeOf (TWaveHdr));
        write_next_buffer (p_wave_hdr2);
      end;
  end;
end;


procedure TForm1.write_next_buffer (header: pWaveHdr);
begin
  if shutoff then Exit;
  with header^ do
    begin
    // fill buffer with sinewave data, record the frequency in the user field
    fill_buffer_with_sinewave (pBuffer (lpData), 0, dwBufferLength div 2);
    dwUser := round (f);
    end;
  last_f := f;
  // write the buffer and bump the number written
  waveOutWrite (hWave_out, header, SizeOf (TWaveHdr));
  Inc (buffers_written);
  if speed = no_sweep
  then
    all_written := False
  else
    begin
    if log_lin = linear
    then f := f + f_step
    else f := f * f_ratio;
    // check to see if we've reached the maximum frequency
    all_written := f > f_max;
    end;
end;


procedure TForm1.mm_wom_done (var Msg: tMessage);
// handle the wave out done message by writing the next buffer, if required
var
   free_header: pWaveHdr;
begin
  case speed of
    fast_smooth, fast_stepped:
      begin
      // nothing to do
      end;
    slow, no_sweep:
      begin
      // note the fact that another buffer has been completed
      Inc (buffers_played);
      // point to wave header just completed, i.e. the next free buffer
      free_header := pWaveHdr (msg.lParam);
      if not shutoff then
        begin
        if (all_written) or (buffers_played >= buffers_written)
        then
          begin
          // everything written has been played
          shutoff := true;
          sweep_running := false;
          closing := false;         // say we're not closing just yet
          end
        else
          begin
          // make a note of the last frequency for the user
          lblFnow.Caption := Format ('%.0f Hz', [last_f]);
          // and write the next buffer, re-using the one just played
          write_next_buffer (free_header);
          end
        end;
      end;
  end;
  if shutoff then
    begin
    waveOutReset (hWave_out);
    waveOutClose (hWave_out);
    end;
end;


procedure TForm1.mm_wom_close (var Msg: tMessage);
// handle the wave out close message, release the wave headers
begin
  waveOutUnprepareHeader (hWave_out, p_wave_hdr1, SizeOf (TWaveHdr));
  waveOutUnprepareHeader (hWave_out, p_wave_hdr2, SizeOf (TWaveHdr));
  p_wave_hdr1 := pWaveHdr (GlobalLock (hWave_hdr1));
  if p_wave_hdr1 = nil then
    ShowMessage ('Failed to re-lock buffer p_wave_hdr1!');
  p_wave_hdr2 := pWaveHdr (GlobalLock (hWave_hdr2));
  if p_wave_hdr2 = nil then
    ShowMessage ('Failed to re-lock buffer p_wave_hdr2!');
  lblFnow.Visible := False;
  btnStart.Caption := 'Start';
  hWave_out := 0;
  closed := true;
  if closing then Close;
end;


procedure TForm1.do_sine_table;
var
  i: 0..sine_table_samples - 1;
  y, magnitude: extended;
begin
  if sine_table_done then Exit;     // nothing to do

  // convert dB to a mathematical fraction of full amplitude
  case level of
     dB0: magnitude := 1.0;
     dB3: magnitude := 0.707;
     dB6: magnitude := 0.5;
     dB9: magnitude := 0.354;
    dB12: magnitude := 0.25;
    dB15: magnitude := 0.177;
    dB18: magnitude := 0.125;
    dB20: magnitude := 0.1;
  else
    magnitude := 0.25;   // should never be here, but just in case.....
  end;

  // yes, I realise we could symmetry to reduce the number of computations
  // required, but it really doesn't take that long.
  for i := 0 to sine_table_samples - 1 do
    begin
    // Assume 16-bit audio goes from -32767..32767, avoids clipping.
    // There are only 2^15 samples here, this simplfies the subsequent angle
    // calculation but might restrict the dynamic range produced with noise
    // sidebands.  However, in the quality of equipment likely to be
    // encountered this won't matter.  You've got the source code, so
    // you can alter this if you like.
    y := round (magnitude * (32767.0 * sin (2.0* i * Pi / sine_table_samples)));
    sine_table^ [i] := round (y);
    end;

  sine_table_done := true;
end;


procedure TForm1.fill_buffer_with_sinewave (bfr: pBuffer;  index, samples: integer);
const
  fract_bits = 15;
var
  sample: integer;
  d_angle: integer;      // 32-bit number, with 14 fractional bits, i.e. 17.15
  max_angle: integer;
  w: audio_sample;
begin
  // compute the angular step per sample corresponding to the desired frequency
  d_angle := round ((sine_table_samples shl fract_bits) * f / sample_rate);
  // this is the maximum number of samples in the sine table
  max_angle := (sine_table_samples shl fract_bits) - 1;
  for sample := 0 to samples - 1 do
    begin
    w := sine_table^ [angle shr fract_bits];   // get current sine value
    bfr^ [index] := w;                         // store it in the caller's buffer
    Inc (index);                               // bump the buffer pointer
    Inc (angle, d_angle);                      // bump the angle
    angle := angle and max_angle;              // wrap to 360 degrees
    end;
end;


function TForm1.fill_single_sweep_bfr (bfr: pBuffer;  num_freqs: integer): integer;
// This procedure fills a single buffer with a frequency sweep.
// To allow for oscilloscope retrace and retrigger time, the buffer
// is prefixed with about 25% duration of silence.
// Both log and linear sweeps can be provided
// resturn the number of samples in the buffer
var
  sample, chunk_samples, retrace_steps: integer;
  i, n_freq: integer;
begin
  // for linear sweep, compute the frequency step
  f_step := (f_max + 0.01 - f_min) / (num_freqs-1);

  // for log sweep, compute the frequency ratio per step
  f_ratio := exp (ln (f_max/f_min) / (num_freqs-1));

  retrace_steps := num_freqs div 3;    {allow about 25% retrace time}
  chunk_samples := buffer_bytes div (2 * (num_freqs + retrace_steps));
  sample := 0;
  angle := 0;
  f := f_min;

  // for all buffer chunks, including silence
  for n_freq := 1 to retrace_steps + num_freqs do
    begin
    if n_freq <= retrace_steps
    then
      for i := 0 to chunk_samples - 1 do    // over the entire chunk
        begin
        bfr^ [sample] := 0;                 // insert silence
        Inc (sample);                       // point to next sample
        end
    else
      begin
      // stuff sinewave into this chunk
      fill_buffer_with_sinewave (bfr, sample, chunk_samples);
      Inc (sample, chunk_samples);
      // compute next frequency according to the sweep mode
      if log_lin = linear
      then f := f + f_step
      else f := f * f_ratio;
      end;
    end;

  Result := sample;
end;


procedure TForm1.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
  stop_sweep;
  shutoff := true;
end;


end.